import Utility.Tmp.Dir
import Utility.CopyFile
import Utility.Directory.Create
-import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
-import qualified System.FilePath.ByteString as P
-
canMergeToAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> Annex Bool
canMergeToAdjustedBranch tomerge (origbranch, adj) =
inRepo $ Git.Branch.changed currbranch tomerge
changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do
git_dir <- fromRepo Git.localGitDir
tmpwt <- fromRepo gitAnnexMergeDir
- withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath "git") $ \tmpgit -> withWorkTreeRelated tmpgit $
+ withTmpDirIn othertmpdir (literalOsPath "git") $ \tmpgit -> withWorkTreeRelated tmpgit $
withemptydir git_dir tmpwt $ withWorkTree tmpwt $ do
- let tmpgit' = toRawFilePath tmpgit
- liftIO $ writeFile (tmpgit </> "HEAD") (fromRef updatedorig)
+ liftIO $ F.writeFile'
+ (tmpgit </> literalOsPath "HEAD")
+ (fromRef' updatedorig)
-- Copy in refs and packed-refs, to work
-- around bug in git 2.13.0, which
-- causes it not to look in GIT_DIR for refs.
refs <- liftIO $ emptyWhenDoesNotExist $
dirContentsRecursive $
- git_dir P.</> "refs"
- let refs' = (git_dir P.</> "packed-refs") : refs
+ git_dir </> literalOsPath "refs"
+ let refs' = (git_dir </> literalOsPath "packed-refs") : refs
liftIO $ forM_ refs' $ \src -> do
- whenM (R.doesPathExist src) $ do
+ whenM (doesFileExist src) $ do
dest <- relPathDirToFile git_dir src
- let dest' = tmpgit' P.</> dest
+ let dest' = tmpgit </> dest
createDirectoryUnder [git_dir]
- (P.takeDirectory dest')
+ (takeDirectory dest')
void $ createLinkOrCopy src dest'
-- This reset makes git merge not care
-- that the work tree is empty; otherwise
if merged
then do
!mergecommit <- liftIO $ extractSha
- <$> F.readFile' (toOsPath (tmpgit' P.</> "HEAD"))
+ <$> F.readFile' (tmpgit </> literalOsPath "HEAD")
-- This is run after the commit lock is dropped.
return $ postmerge mergecommit
else return $ return False
setup = do
whenM (doesDirectoryExist d) $
removeDirectoryRecursive d
- createDirectoryUnder [git_dir] (toRawFilePath d)
+ createDirectoryUnder [git_dir] d
cleanup _ = removeDirectoryRecursive d
{- A merge commit has been made between the basisbranch and
#ifndef mingw32_HOST_OS
import Utility.ThreadScheduler
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
import Utility.FileMode
import System.Posix.User
import qualified Utility.LockFile.Posix as Posix
#ifndef mingw32_HOST_OS
import System.PosixCompat.Files (ownerReadMode, isNamedPipe)
import Data.Either
-import qualified System.FilePath.ByteString as P
import Control.Concurrent.Async
#endif
Just _ -> return False
noAnnexFileContent' :: Annex (Maybe String)
-noAnnexFileContent' = inRepo $
- noAnnexFileContent . fmap fromRawFilePath . Git.repoWorkTree
+noAnnexFileContent' = inRepo $ noAnnexFileContent . Git.repoWorkTree
genDescription :: Maybe String -> Annex UUIDDesc
genDescription (Just d) = return $ UUIDDesc $ encodeBS d
genDescription Nothing = do
- reldir <- liftIO . relHome . fromRawFilePath
+ reldir <- liftIO . relHome
=<< liftIO . absPath
=<< fromRepo Git.repoPath
hostname <- fromMaybe "" <$> liftIO getHostname
objectDirNotPresent :: Annex Bool
objectDirNotPresent = do
- d <- fromRawFilePath <$> fromRepo gitAnnexObjectDir
+ d <- fromRepo gitAnnexObjectDir
exists <- liftIO $ doesDirectoryExist d
when exists $ guardSafeToUseRepo $
giveup $ unwords $
[ "This repository is not initialized for use"
- , "by git-annex, but " ++ d ++ " exists,"
+ , "by git-annex, but " ++ fromOsPath d ++ " exists,"
, "which indicates this repository was used by"
, "git-annex before, and may have lost its"
, "annex.uuid and annex.version configs. Either"
, ""
-- This mirrors git's wording.
, "To add an exception for this directory, call:"
- , "\tgit config --global --add safe.directory " ++ fromRawFilePath p
+ , "\tgit config --global --add safe.directory " ++ fromOsPath p
]
, a
)
probeCrippledFileSystem'
:: (MonadIO m, MonadCatch m)
- => RawFilePath
- -> Maybe (RawFilePath -> m ())
- -> Maybe (RawFilePath -> m ())
+ => OsPath
+ -> Maybe (OsPath -> m ())
+ -> Maybe (OsPath -> m ())
-> Bool
-> m (Bool, [String])
#ifdef mingw32_HOST_OS
probeCrippledFileSystem' _ _ _ _ = return (True, [])
#else
probeCrippledFileSystem' tmp freezecontent thawcontent hasfreezehook = do
- let f = tmp P.</> "gaprobe"
- let f' = fromRawFilePath f
- liftIO $ writeFile f' ""
- r <- probe f'
+ let f = tmp </> literalOsPath "gaprobe"
+ liftIO $ F.writeFile' f ""
+ r <- probe f
void $ tryNonAsync $ (fromMaybe (liftIO . allowWrite) thawcontent) f
- liftIO $ removeFile f'
+ liftIO $ removeFile f
return r
where
probe f = catchDefaultIO (True, []) $ do
- let f2 = f ++ "2"
- liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f2)
- liftIO $ R.createSymbolicLink (toRawFilePath f) (toRawFilePath f2)
- liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f2)
- (fromMaybe (liftIO . preventWrite) freezecontent) (toRawFilePath f)
+ let f2 = f <> literalOsPath "2"
+ liftIO $ removeWhenExistsWith removeFile f2
+ liftIO $ R.createSymbolicLink (fromOsPath f) (fromOsPath f2)
+ liftIO $ removeWhenExistsWith removeFile f2
+ (fromMaybe (liftIO . preventWrite) freezecontent) f
-- Should be unable to write to the file (unless
-- running as root). But some crippled
-- filesystems ignore write bit removals or ignore
-- permissions entirely.
- ifM ((== Just False) <$> liftIO (checkContentWritePerm' UnShared (toRawFilePath f) Nothing hasfreezehook))
+ ifM ((== Just False) <$> liftIO (checkContentWritePerm' UnShared f Nothing hasfreezehook))
( return (True, ["Filesystem does not allow removing write bit from files."])
, liftIO $ ifM ((== 0) <$> getRealUserID)
( return (False, [])
, do
r <- catchBoolIO $ do
- writeFile f "2"
+ F.writeFile' f "2"
return True
if r
then return (True, ["Filesystem allows writing to files whose write bit is not set."])
probeLockSupport = return True
#else
probeLockSupport = withEventuallyCleanedOtherTmp $ \tmp -> do
- let f = tmp P.</> "lockprobe"
+ let f = tmp </> literalOsPath "lockprobe"
mode <- annexFileMode
annexrunner <- Annex.makeRunner
liftIO $ withAsync (warnstall annexrunner) (const (go f mode))
where
go f mode = do
- removeWhenExistsWith R.removeLink f
+ removeWhenExistsWith removeFile f
let locktest = bracket
(Posix.lockExclusive (Just mode) f)
Posix.dropLock
(const noop)
ok <- isRight <$> tryNonAsync locktest
- removeWhenExistsWith R.removeLink f
+ removeWhenExistsWith removeFile f
return ok
warnstall annexrunner = do
return False
#else
withEventuallyCleanedOtherTmp $ \tmp -> do
- let f = tmp P.</> "gaprobe"
- let f2 = tmp P.</> "gaprobe2"
+ let f = tmp </> literalOsPath "gaprobe"
+ let f2 = tmp </> literalOsPath "gaprobe2"
liftIO $ do
- removeWhenExistsWith R.removeLink f
- removeWhenExistsWith R.removeLink f2
+ removeWhenExistsWith removeFile f
+ removeWhenExistsWith removeFile f2
ms <- tryIO $ do
- R.createNamedPipe f ownerReadMode
- R.createLink f f2
- R.getFileStatus f
- removeWhenExistsWith R.removeLink f
- removeWhenExistsWith R.removeLink f2
+ R.createNamedPipe (fromOsPath f) ownerReadMode
+ R.createLink (fromOsPath f) (fromOsPath f2)
+ R.getFileStatus (fromOsPath f)
+ removeWhenExistsWith removeFile f
+ removeWhenExistsWith removeFile f2
return $ either (const False) isNamedPipe ms
#endif
-- could result in password prompts for http credentials,
-- which would then not end up cached in this process's state.
_ <- remotelist
- rp <- fromRawFilePath <$> fromRepo Git.repoPath
+ rp <- fromRepo Git.repoPath
withNullHandle $ \nullh -> gitAnnexChildProcess "init"
[ Param "--autoenable" ]
(\p -> p
{ std_out = UseHandle nullh
, std_err = UseHandle nullh
, std_in = UseHandle nullh
- , cwd = Just rp
+ , cwd = Just (fromOsPath rp)
}
)
(\_ _ _ pid -> void $ waitForProcess pid)
{- .git/annex/merge/ is used as a empty work tree for merges in
- adjusted branches. -}
-gitAnnexMergeDir :: Git.Repo -> FilePath
-gitAnnexMergeDir r = fromOsPath $
- addTrailingPathSeparator $ gitAnnexDir r </> literalOsPath "merge"
+gitAnnexMergeDir :: Git.Repo -> OsPath
+gitAnnexMergeDir r = addTrailingPathSeparator $
+ gitAnnexDir r </> literalOsPath "merge"
{- .git/annex/transfer/ is used to record keys currently
- being transferred, and other transfer bookkeeping info. -}
import Annex.StallDetection
import Backend (isCryptographicallySecureKey)
import Types.StallDetection
-import qualified Utility.RawFilePath as R
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM hiding (retry)
import qualified Data.Map.Strict as M
-import qualified System.FilePath.ByteString as P
import Data.Ord
-- Upload, supporting canceling detected stalls.
go sd = getViaTmp (Remote.retrievalSecurityPolicy r) vc key f Nothing $ \dest ->
download' (Remote.uuid r) key f sd d (go' dest) witness
go' dest p = verifiedAction $
- Remote.retrieveKeyFile r key f (fromRawFilePath dest) p vc
+ Remote.retrieveKeyFile r key f dest p vc
vc = Remote.RemoteVerify r
-- Download, not supporting canceling detected stalls.
else recordFailedTransfer t info
return v
- prep :: RawFilePath -> Maybe RawFilePath -> Annex () -> ModeSetter -> Annex (Maybe (LockHandle, Maybe LockHandle), Bool)
+ prep :: OsPath -> Maybe OsPath -> Annex () -> ModeSetter -> Annex (Maybe (LockHandle, Maybe LockHandle), Bool)
#ifndef mingw32_HOST_OS
prep lckfile moldlckfile createtfile mode = catchPermissionDenied (const prepfailed) $ do
- createAnnexDirectory $ P.takeDirectory lckfile
+ createAnnexDirectory $ takeDirectory lckfile
tryLockExclusive (Just mode) lckfile >>= \case
Nothing -> return (Nothing, True)
-- Since the lock file is removed in cleanup,
createtfile
return (Just (lockhandle, Nothing), False)
Just oldlckfile -> do
- createAnnexDirectory $ P.takeDirectory oldlckfile
+ createAnnexDirectory oldlckfile
tryLockExclusive (Just mode) oldlckfile >>= \case
Nothing -> do
liftIO $ dropLock lockhandle
)
#else
prep lckfile moldlckfile createtfile _mode = catchPermissionDenied (const prepfailed) $ do
- createAnnexDirectory $ P.takeDirectory lckfile
+ createAnnexDirectory lckfile
catchMaybeIO (liftIO $ lockExclusive lckfile) >>= \case
Just (Just lockhandle) -> case moldlckfile of
Nothing -> do
createtfile
return (Just (lockhandle, Nothing), False)
Just oldlckfile -> do
- createAnnexDirectory $ P.takeDirectory oldlckfile
+ createAnnexDirectory oldlckfile
catchMaybeIO (liftIO $ lockExclusive oldlckfile) >>= \case
Just (Just oldlockhandle) -> do
createtfile
cleanup _ _ _ Nothing = noop
cleanup tfile lckfile moldlckfile (Just (lockhandle, moldlockhandle)) = do
- void $ tryIO $ R.removeLink tfile
+ void $ tryIO $ removeFile tfile
#ifndef mingw32_HOST_OS
- void $ tryIO $ R.removeLink lckfile
- maybe noop (void . tryIO . R.removeLink) moldlckfile
+ void $ tryIO $ removeFile lckfile
+ maybe noop (void . tryIO . removeFile) moldlckfile
maybe noop dropLock moldlockhandle
dropLock lockhandle
#else
maybe noop dropLock moldlockhandle
dropLock lockhandle
void $ tryIO $ R.removeLink lckfile
- maybe noop (void . tryIO . R.removeLink) moldlckfile
+ maybe noop (void . tryIO . removeFile) moldlckfile
#endif
retry numretries oldinfo metervar run =
import Annex.Content
import Annex.Transfer
import Annex.ChangedRefs
+import Annex.Verify
import P2P.Protocol
import P2P.IO
import Logs.Location
import Types.NumCopies
import Utility.Metered
import Utility.MonotonicClock
-import Annex.Verify
+import qualified Utility.FileIO as F
import Control.Monad.Free
import Control.Concurrent.STM
size <- liftIO $ catchDefaultIO 0 $ getFileSize tmp
runner (next (Len size))
FileSize f next -> do
- size <- liftIO $ catchDefaultIO 0 $ getFileSize (toRawFilePath f)
+ size <- liftIO $ catchDefaultIO 0 $ getFileSize f
runner (next (Len size))
ContentSize k next -> do
let getsize = liftIO . catchMaybeIO . getFileSize
let runtransfer ti =
Right <$> transfer download' k af Nothing (\p ->
logStatusAfter NoLiveUpdate k $ getViaTmp rsp DefaultVerify k af Nothing $ \tmp ->
- storefile (fromRawFilePath tmp) o l getb iv validitycheck p ti)
+ storefile tmp o l getb iv validitycheck p ti)
let fallback = return $ Left $
ProtoFailureMessage "transfer already in progress, or unable to take transfer lock"
checktransfer runtransfer fallback
v <- runner getb
case v of
Right b -> do
- liftIO $ withBinaryFile dest ReadWriteMode $ \h -> do
+ liftIO $ F.withBinaryFile dest ReadWriteMode $ \h -> do
p' <- resumeVerifyFromOffset o incrementalverifier p h
meteredWrite p' (writeVerifyChunk incrementalverifier h) b
indicatetransferred ti
rightsize <- do
- sz <- liftIO $ getFileSize (toRawFilePath dest)
+ sz <- liftIO $ getFileSize dest
return (toInteger sz == l + o)
runner validitycheck >>= \case
Nothing -> return (True, UnVerified)
Just True -> return (True, Verified)
Just False -> do
- verificationOfContentFailed (toRawFilePath dest)
+ verificationOfContentFailed dest
return (False, UnVerified)
| otherwise -> return (False, UnVerified)
Nothing -> return (rightsize, UnVerified)
sinkfile f (Offset o) checkchanged sender p ti = bracket setup cleanup go
where
- setup = liftIO $ openBinaryFile f ReadMode
+ setup = liftIO $ F.openBinaryFile f ReadMode
cleanup = liftIO . hClose
go h = do
let p' = offsetMeterUpdate p (toBytesProcessed o)
import Utility.Url (BasicAuth(..))
import Utility.HumanTime
import Utility.STM
+import qualified Utility.FileIO as F
import qualified Git.Credential as Git
import Servant hiding (BasicAuthData(..))
-> Key
-> Maybe Offset
-> AssociatedFile
- -> FilePath
+ -> OsPath
-> FileSize
-> Annex Bool
-- ^ Called after sending the file to check if it's valid.
liftIO $ atomically $ takeTMVar checkv
validitycheck >>= liftIO . atomically . putTMVar checkresultv
checkerthread <- liftIO . async =<< forkState checker
- v <- liftIO $ withBinaryFile contentfile ReadMode $ \h -> do
+ v <- liftIO $ F.withBinaryFile contentfile ReadMode $ \h -> do
when (offset /= 0) $
hSeek h AbsoluteSeek offset
withClientM (cli (stream h checkv checkresultv)) clientenv return
import Utility.MonotonicClock
import Types.UUID
import Annex.ChangedRefs
-import qualified Utility.RawFilePath as R
import Control.Monad.Free
import Control.Monad.IO.Class
-- Note that while the callback is running, other connections won't be
-- processed, so longterm work should be run in a separate thread by
-- the callback.
-serveUnixSocket :: FilePath -> (Handle -> IO ()) -> IO ()
+serveUnixSocket :: OsPath -> (Handle -> IO ()) -> IO ()
serveUnixSocket unixsocket serveconn = do
- removeWhenExistsWith R.removeLink (toRawFilePath unixsocket)
+ removeWhenExistsWith removeFile unixsocket
soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
- S.bind soc (S.SockAddrUnix unixsocket)
+ S.bind soc (S.SockAddrUnix (fromOsPath unixsocket))
-- Allow everyone to read and write to the socket,
-- so a daemon like tor, that is probably running as a different
-- de sock $ addModes
-- Connections have to authenticate to do anything,
-- so it's fine that other local users can connect to the
-- socket.
- modifyFileMode (toOsPath unixsocket) $ addModes
+ modifyFileMode unixsocket $ addModes
[groupReadMode, groupWriteMode, otherReadMode, otherWriteMode]
S.listen soc 2
forever $ do
= TmpContentSize Key (Len -> c)
-- ^ Gets size of the temp file where received content may have
-- been stored. If not present, returns 0.
- | FileSize FilePath (Len -> c)
+ | FileSize OsPath (Len -> c)
-- ^ Gets size of the content of a file. If not present, returns 0.
| ContentSize Key (Maybe Len -> c)
-- ^ Gets size of the content of a key, when the full content is
-- present.
- | ReadContent Key AssociatedFile (Maybe FilePath) Offset (L.ByteString -> Proto Validity -> Proto (Maybe [UUID])) (Maybe [UUID] -> c)
+ | ReadContent Key AssociatedFile (Maybe OsPath) Offset (L.ByteString -> Proto Validity -> Proto (Maybe [UUID])) (Maybe [UUID] -> c)
-- ^ Reads the content of a key and sends it to the callback.
-- Must run the callback, or terminate the protocol connection.
--
-- Note: The ByteString may not contain the entire remaining content
-- of the key. Only once the temp file size == Len has the whole
-- content been transferred.
- | StoreContentTo FilePath (Maybe IncrementalVerifier) Offset Len (Proto L.ByteString) (Proto (Maybe Validity)) ((Bool, Verification) -> c)
+ | StoreContentTo OsPath (Maybe IncrementalVerifier) Offset Len (Proto L.ByteString) (Proto (Maybe Validity)) ((Bool, Verification) -> c)
-- ^ Like StoreContent, but stores the content to a temp file.
| SendContentWith (L.ByteString -> Annex (Maybe Validity -> Annex Bool)) (Proto L.ByteString) (Proto (Maybe Validity)) (Bool -> c)
-- ^ Reads content from the Proto L.ByteString and sends it to the
REMOVE_BEFORE remoteendtime key
checkSuccessFailurePlus
-get :: FilePath -> Key -> Maybe IncrementalVerifier -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification)
+get :: OsPath -> Key -> Maybe IncrementalVerifier -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification)
get dest key iv af m p =
receiveContent (Just m) p sizer storer noothermessages $ \offset ->
GET offset (ProtoAssociatedFile af) key
(ServeReadOnly, UploadPack) -> a Nothing
(ServeReadOnly, ReceivePack) -> a (Just sendReadOnlyError)
-sendContent :: Key -> AssociatedFile -> Maybe FilePath -> Offset -> MeterUpdate -> Proto (Maybe [UUID])
+sendContent :: Key -> AssociatedFile -> Maybe OsPath -> Offset -> MeterUpdate -> Proto (Maybe [UUID])
sendContent key af o offset@(Offset n) p = go =<< local (contentSize key)
where
go (Just (Len totallen)) = do
import qualified Data.Map as M
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
-import qualified System.FilePath.ByteString as P
import Data.ByteString.Lazy.UTF8 (fromString)
import Control.Concurrent.Async
, getRepo = return r
, gitconfig = gc
, localpath = if bupLocal buprepo && not (null buprepo)
- then Just buprepo
+ then Just (toOsPath buprepo)
else Nothing
, remotetype = remote
, availability = if null buprepo
then pure LocallyAvailable
- else checkPathAvailability (bupLocal buprepo) buprepo
+ else checkPathAvailability (bupLocal buprepo) (toOsPath buprepo)
, readonly = False
, appendonly = False
, untrustworthy = False
(sshcmd, sshparams) <- Ssh.toRepo NoConsumeStdin r c remotecmd
liftIO $ runner sshcmd sshparams
where
- path = fromRawFilePath $ Git.repoPath r
+ path = fromOsPath $ Git.repoPath r
base = fromMaybe path (stripPrefix "/~/" path)
dir = shellEscape base
bup2GitRemote "" = do
-- bup -r "" operates on ~/.bup
h <- myHomeDir
- Git.Construct.fromPath $ toRawFilePath $ h </> ".bup"
+ Git.Construct.fromPath $ toOsPath h </> literalOsPath ".bup"
bup2GitRemote r
| bupLocal r =
if "/" `isPrefixOf` r
- then Git.Construct.fromPath (toRawFilePath r)
+ then Git.Construct.fromPath (toOsPath r)
else giveup "please specify an absolute path"
| otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir
where
lockBup :: Bool -> Remote -> Annex a -> Annex a
lockBup writer r a = do
dir <- fromRepo gitAnnexRemotesDir
- unlessM (liftIO $ doesDirectoryExist (fromRawFilePath dir)) $
+ unlessM (liftIO $ doesDirectoryExist dir) $
createAnnexDirectory dir
let remoteid = fromUUID (uuid r)
- let lck = dir P.</> remoteid <> ".lck"
+ let lck = dir </> remoteid <> literalOsPath ".lck"
if writer
then withExclusiveLock lck a
else withSharedLock lck a
import qualified Data.Map as M
import qualified Data.ByteString as S
-import qualified Data.ByteString.Lazy as L
-import qualified System.FilePath.ByteString as P
import Data.Default
import Annex.Common
import Annex.UUID
import Annex.Ssh
import Annex.Perms
+import Messages.Progress
+import Types.ProposedAccepted
+import Logs.Remote
import qualified Remote.Rsync
import qualified Remote.Directory
import Utility.Rsync
import Utility.Tmp
-import Logs.Remote
import Utility.Gpg
import Utility.SshHost
import Utility.Directory.Create
-import Messages.Progress
-import Types.ProposedAccepted
+import qualified Utility.FileIO as F
remote :: RemoteType
remote = specialRemoteType $ RemoteType
- which is needed for rsync of objects to it to work.
-}
rsyncsetup = Remote.Rsync.withRsyncScratchDir $ \tmp -> do
- createAnnexDirectory (toRawFilePath tmp P.</> objectDir)
+ createAnnexDirectory (tmp </> objectDir)
dummycfg <- liftIO dummyRemoteGitConfig
let (rsynctransport, rsyncurl, _) = rsyncTransport r dummycfg
- let tmpconfig = tmp </> "config"
+ let tmpconfig = fromOsPath $ tmp </> literalOsPath "config"
opts <- rsynctransport
void $ liftIO $ rsync $ opts ++
[ Param $ rsyncurl ++ "/config"
void $ Git.Config.changeFile tmpconfig denyNonFastForwards (Git.Config.boolConfig' False)
ok <- liftIO $ rsync $ opts ++
[ Param "--recursive"
- , Param $ tmp ++ "/"
+ , Param $ fromOsPath tmp ++ "/"
, Param rsyncurl
]
unless ok $
store' repo r rsyncopts accessmethod
| not $ Git.repoIsUrl repo =
byteStorer $ \k b p -> guardUsable repo (giveup "cannot access remote") $ liftIO $ do
- let tmpdir = Git.repoPath repo P.</> "tmp" P.</> keyFile k
+ let tmpdir = Git.repoPath repo </> literalOsPath "tmp" </> keyFile k
void $ tryIO $ createDirectoryUnder [Git.repoPath repo] tmpdir
- let tmpf = tmpdir P.</> keyFile k
- meteredWriteFile p (fromRawFilePath tmpf) b
- let destdir = parentDir $ toRawFilePath $ gCryptLocation repo k
+ let tmpf = tmpdir </> keyFile k
+ meteredWriteFile p tmpf b
+ let destdir = parentDir $ gCryptLocation repo k
Remote.Directory.finalizeStoreGeneric (Git.repoPath repo) tmpdir destdir
| Git.repoIsSsh repo = if accessShell r
then fileStorer $ \k f p -> do
oh <- mkOutputHandler
ok <- Ssh.rsyncHelper oh (Just p)
- =<< Ssh.rsyncParamsRemote r Upload k f
+ =<< Ssh.rsyncParamsRemote r Upload k
+ (fromOsPath f)
unless ok $
giveup "rsync failed"
else storersync
retrieve' repo r rsyncopts accessmethod
| not $ Git.repoIsUrl repo = byteRetriever $ \k sink ->
guardUsable repo (giveup "cannot access remote") $
- sink =<< liftIO (L.readFile $ gCryptLocation repo k)
+ sink =<< liftIO (F.readFile $ gCryptLocation repo k)
| Git.repoIsSsh repo = if accessShell r
then fileRetriever $ \f k p -> do
ps <- Ssh.rsyncParamsRemote r Download k
- (fromRawFilePath f)
+ (fromOsPath f)
oh <- mkOutputHandler
unlessM (Ssh.rsyncHelper oh (Just p) ps) $
giveup "rsync failed"
remove' repo r rsyncopts accessmethod proof k
| not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $
liftIO $ Remote.Directory.removeDirGeneric True
- (toRawFilePath (gCryptTopDir repo))
- (parentDir (toRawFilePath (gCryptLocation repo k)))
+ (gCryptTopDir repo)
+ (parentDir (gCryptLocation repo k))
| Git.repoIsSsh repo = shellOrRsync r removeshell removersync
| accessmethod == AccessRsyncOverSsh = removersync
| otherwise = unsupportedUrl
checkrsync = Remote.Rsync.checkKey rsyncopts k
checkshell = Ssh.inAnnex repo k
-gCryptTopDir :: Git.Repo -> FilePath
-gCryptTopDir repo = Git.repoLocation repo </> fromRawFilePath objectDir
+gCryptTopDir :: Git.Repo -> OsPath
+gCryptTopDir repo = toOsPath (Git.repoLocation repo) </> objectDir
{- Annexed objects are hashed using lower-case directories for max
- portability. -}
-gCryptLocation :: Git.Repo -> Key -> FilePath
+gCryptLocation :: Git.Repo -> Key -> OsPath
gCryptLocation repo key = gCryptTopDir repo
- </> fromRawFilePath (keyPath key (hashDirLower def))
+ </> keyPath key (hashDirLower def)
data AccessMethod = AccessRsyncOverSsh | AccessGitAnnexShell
deriving (Eq)
let (rsynctransport, rsyncurl, _) = rsyncTransport r gc
opts <- rsynctransport
liftIO $ do
- withTmpFile (toOsPath "tmpconfig") $ \tmpconfig _ -> do
- let tmpconfig' = fromRawFilePath $ fromOsPath tmpconfig
+ withTmpFile (literalOsPath "tmpconfig") $ \tmpconfig _ -> do
+ let tmpconfig' = fromOsPath tmpconfig
void $ rsync $ opts ++
[ Param $ rsyncurl ++ "/config"
, Param tmpconfig'
import Utility.Metered
import Utility.Env
import Utility.Batch
+import qualified Utility.FileIO as F
import Remote.Helper.Git
import Remote.Helper.Messages
import Remote.Helper.ExportImport
geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do
let url = Git.repoLocation r ++ "/config"
- v <- withTmpFile (toOsPath "git-annex.tmp") $ \tmpfile h -> do
+ v <- withTmpFile (literalOsPath "git-annex.tmp") $ \tmpfile h -> do
liftIO $ hClose h
- let tmpfile' = fromRawFilePath $ fromOsPath tmpfile
- Url.download' nullMeterUpdate Nothing url tmpfile' uo >>= \case
+ Url.download' nullMeterUpdate Nothing url tmpfile uo >>= \case
Right () ->
pipedconfig Git.Config.ConfigNullList
False url "git"
, Param "--null"
, Param "--list"
, Param "--file"
- , File tmpfile'
+ , File (fromOsPath tmpfile)
] >>= return . \case
Right r' -> Right r'
Left exitcode -> Left $ "git config exited " ++ show exitcode
| remoteAnnexBare remoteconfig == Just False = annexLocationsNonBare gc key
| otherwise = annexLocationsBare gc key
#ifndef mingw32_HOST_OS
- locs' = map fromRawFilePath locs
+ locs' = map fromOsPath locs
#else
- locs' = map (replace "\\" "/" . fromRawFilePath) locs
+ locs' = map (replace "\\" "/" . fromOsPath) locs
#endif
remoteconfig = gitconfig r
failedlock = giveup "can't lock content"
{- Tries to copy a key's content from a remote's annex to a file. -}
-copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification
copyFromRemote r st key file dest meterupdate vc = do
repo <- getRepo r
copyFromRemote'' repo r st key file dest meterupdate vc
-copyFromRemote'' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+copyFromRemote'' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification
copyFromRemote'' repo r st@(State connpool _ _ _ _) key af dest meterupdate vc
| isP2PHttp r = copyp2phttp
| Git.repoIsHttp repo = verifyKeyContentIncrementally vc key $ \iv -> do
<|> remoteAnnexBwLimit (gitconfig r)
copyp2phttp = verifyKeyContentIncrementally vc key $ \iv -> do
- startsz <- liftIO $ tryWhenExists $
- getFileSize (toRawFilePath dest)
- bracketIO (openBinaryFile dest ReadWriteMode) (hClose) $ \h -> do
+ startsz <- liftIO $ tryWhenExists $ getFileSize dest
+ bracketIO (F.openBinaryFile dest ReadWriteMode) (hClose) $ \h -> do
metered (Just meterupdate) key bwlimit $ \_ p -> do
p' <- case startsz of
Just startsz' -> liftIO $ do
Valid -> return ()
Invalid -> giveup "Transfer failed"
-copyFromRemoteCheap :: State -> Git.Repo -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ())
+copyFromRemoteCheap :: State -> Git.Repo -> Maybe (Key -> AssociatedFile -> OsPath -> Annex ())
#ifndef mingw32_HOST_OS
copyFromRemoteCheap st repo
| not $ Git.repoIsUrl repo = Just $ \key _af file -> guardUsable repo (giveup "cannot access remote") $ do
gc <- getGitConfigFromState st
loc <- liftIO $ gitAnnexLocation key repo gc
- liftIO $ ifM (R.doesPathExist loc)
+ liftIO $ ifM (doesFileExist loc)
( do
absloc <- absPath loc
- R.createSymbolicLink absloc (toRawFilePath file)
+ R.createSymbolicLink
+ (fromOsPath absloc)
+ (fromOsPath file)
, giveup "remote does not contain key"
)
| otherwise = Nothing
#endif
{- Tries to copy a key's content to a remote's annex. -}
-copyToRemote :: Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
+copyToRemote :: Remote -> State -> Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex ()
copyToRemote r st key af o meterupdate = do
repo <- getRepo r
copyToRemote' repo r st key af o meterupdate
-copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
+copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex ()
copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate
| isP2PHttp r = prepsendwith copyp2phttp
| not $ Git.repoIsUrl repo = ifM duc
Nothing -> return True
logStatusAfter NoLiveUpdate key $ Annex.Content.getViaTmp rsp verify key af (Just sz) $ \dest ->
metered (Just (combineMeterUpdate meterupdate p)) key bwlimit $ \_ p' ->
- copier object (fromRawFilePath dest) key p' checksuccess verify
+ copier object dest key p' checksuccess verify
)
unless res $
failedsend
r' <- Git.Config.read r
environ <- getEnvironment
let environ' = addEntries
- [ ("GIT_WORK_TREE", fromRawFilePath $ Git.repoPath r')
- , ("GIT_DIR", fromRawFilePath $ Git.localGitDir r')
+ [ ("GIT_WORK_TREE", fromOsPath $ Git.repoPath r')
+ , ("GIT_DIR", fromOsPath $ Git.localGitDir r')
] environ
- batchCommandEnv program (Param "fsck" : params) (Just environ')
+ batchCommandEnv (fromOsPath program)
+ (Param "fsck" : params)
+ (Just environ')
{- The passed repair action is run in the Annex monad of the remote. -}
repairRemote :: Git.Repo -> Annex Bool -> Annex (IO Bool)
-- because they can be modified at any time.
<&&> (not <$> annexThin <$> Annex.getGitConfig)
-type FileCopier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification)
+type FileCopier = OsPath -> OsPath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification)
-- If either the remote or local repository wants to use hard links,
-- the copier will do so (falling back to copying if a hard link cannot be
mkFileCopier :: Bool -> State -> Annex FileCopier
mkFileCopier remotewanthardlink (State _ _ copycowtried _ _) = do
localwanthardlink <- wantHardLink
- let linker = \src dest -> R.createLink (toRawFilePath src) (toRawFilePath dest) >> return True
+ let linker = \src dest -> R.createLink (fromOsPath src) (fromOsPath dest) >> return True
if remotewanthardlink || localwanthardlink
then return $ \src dest k p check verifyconfig ->
ifM (liftIO (catchBoolIO (linker src dest)))
( ifM check
( return (True, Verified)
, do
- verificationOfContentFailed (toRawFilePath dest)
+ verificationOfContentFailed dest
return (False, UnVerified)
)
, copier src dest k p check verifyconfig
where
copier src dest k p check verifyconfig = do
iv <- startVerifyKeyContentIncrementally verifyconfig k
- liftIO (fileCopier copycowtried src dest p iv) >>= \case
+ liftIO (fileCopier copycowtried (fromOsPath src) (fromOsPath dest) p iv) >>= \case
Copied -> ifM check
( finishVerifyKeyContentIncrementally iv
, do
- verificationOfContentFailed (toRawFilePath dest)
+ verificationOfContentFailed dest
return (False, UnVerified)
)
CopiedCoW -> unVerified check
import qualified Annex
import qualified Git
import qualified Git.Types as Git
+import qualified Git.Config
import qualified Git.Url
import qualified Git.Remote
import qualified Git.GCrypt
import Annex.UUID
import Crypto
import Backend.Hash
+import Logs.Remote
+import Logs.RemoteState
import Utility.Hash
import Utility.SshHost
import Utility.Url
-import Logs.Remote
-import Logs.RemoteState
-import qualified Git.Config
+import qualified Utility.FileIO as F
import qualified Network.GitLFS as LFS
import Control.Concurrent.STM
| isEncKey k = Nothing
| otherwise = fromKey keySize k
-mkUploadRequest :: RemoteStateHandle -> Key -> FilePath -> Annex (LFS.TransferRequest, LFS.SHA256, Integer)
+mkUploadRequest :: RemoteStateHandle -> Key -> OsPath -> Annex (LFS.TransferRequest, LFS.SHA256, Integer)
mkUploadRequest rs k content = case (extractKeySha256 k, extractKeySize k) of
(Just sha256, Just size) ->
ret sha256 size
ret sha256 size
_ -> do
sha256 <- calcsha256
- size <- liftIO $ getFileSize (toRawFilePath content)
+ size <- liftIO $ getFileSize content
rememberboth sha256 size
ret sha256 size
where
- calcsha256 = liftIO $ T.pack . show . sha2_256 <$> L.readFile content
+ calcsha256 = liftIO $ T.pack . show . sha2_256 <$> F.readFile content
ret sha256 size = do
let obj = LFS.TransferRequestObject
{ LFS.req_oid = sha256
Nothing -> giveup "unable to parse git-lfs server download url"
Just req -> do
uo <- getUrlOptions
- liftIO $ downloadConduit p iv req (fromRawFilePath dest) uo
+ liftIO $ downloadConduit p iv req dest uo
-- Since git-lfs does not support removing content, nothing needs to be
-- done to lock content in the remote, except for checking that the content
when (u /= remoteuuid) $
logChange lu k u logstatus
-retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification
retrieve gc runner k af dest p verifyconfig = do
iv <- startVerifyKeyContentIncrementally verifyconfig k
let bwlimit = remoteAnnexBwLimitDownload gc <|> remoteAnnexBwLimit gc
let params' = case (debugenabled, debugselector) of
(True, NoDebugSelector) -> Param "--debug" : params
_ -> params
- return (Param command : File (fromRawFilePath dir) : params')
+ return (Param command : File (fromOsPath dir) : params')
uuidcheck NoUUID = []
uuidcheck u@(UUID _) = ["--uuid", fromUUID u]
fieldopts
runBool [Param "fetch", Param $ Git.repoDescribe r]
send (DONESYNCING url ok)
-torSocketFile :: Annex.Annex (Maybe FilePath)
+torSocketFile :: Annex.Annex (Maybe OsPath)
torSocketFile = do
u <- getUUID
let ident = fromUUID u
projects / git-annex.git / commitdiff